Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/pcl/src-16f.lha/compiler/life.lisp

Text File | 1992-12-09 | 39.0 KB | 1,133 lines

;;; -*- Package: C; Log: C.Log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or [e-mail].
;;;
(ext:file-comment
  "$Header: life.lisp,v 1.21 92/08/14 15:20:19 ram Exp $")
;;;
;;; **********************************************************************
;;;
;;;    This file contains the lifetime analysis phase in the compiler.
;;;
;;; Written by Rob MacLachlan
;;;
(in-package 'c)


;;;; Utilities:

;;; Add-Global-Conflict  --  Internal
;;;
;;;    Link in a global-conflicts structure for TN in Block with Number as the
;;; LTN number.  The conflict is inserted in the per-TN Global-Conflicts thread
;;; after the TN's Current-Conflict.  We change the Current-Conflict to point
;;; to the new conflict.  Since we scan the blocks in reverse DFO, this list is
;;; automatically built in order.  We have to actually scan the current
;;; Global-TNs for the block in order to keep that thread sorted.
;;;
(defun add-global-conflict (kind tn block number)
  (declare (type (member :read :write :read-only :live) kind)
       (type tn tn) (type ir2-block block)
       (type (or local-tn-number null) number))
  (let ((new (make-global-conflicts kind tn block number)))
    (let ((last (tn-current-conflict tn)))
      (if last
      (shiftf (global-conflicts-tn-next new)
          (global-conflicts-tn-next last)
          new)
      (shiftf (global-conflicts-tn-next new)
          (tn-global-conflicts tn)
          new)))
    (setf (tn-current-conflict tn) new)

    (insert-block-global-conflict new block))
  (undefined-value))


;;; INSERT-BLOCK-GLOBAL-CONFLICT  --  Internal
;;;
;;;    Do the actual insertion of the conflict New into Block's global
;;; conflicts.
;;;
(defun insert-block-global-conflict (new block)
  (let ((global-num (tn-number (global-conflicts-tn new))))
    (do ((prev nil conf)
     (conf (ir2-block-global-tns block)
           (global-conflicts-next conf)))
    ((or (null conf)
         (> (tn-number (global-conflicts-tn conf)) global-num))
     (if prev
         (setf (global-conflicts-next prev) new)
         (setf (ir2-block-global-tns block) new))
     (setf (global-conflicts-next new) conf))))
  (undefined-value))


;;; Reset-Current-Conflict  --  Internal
;;;
;;;    Reset the Current-Conflict slot in all packed TNs to point to the head
;;; of the Global-Conflicts thread.
;;;
(defun reset-current-conflict (component)
  (do-packed-tns (tn component)
    (setf (tn-current-conflict tn) (tn-global-conflicts tn))))


;;;; Pre-pass:

;;; Convert-To-Global  --  Internal
;;;
;;;    Convert TN (currently local) to be a global TN, since we discovered that
;;; it is referenced in more than one block.  We just add a global-conflicts
;;; structure with a kind derived from the Kill and Live sets.
;;;
(defun convert-to-global (tn)
  (declare (type tn tn))
  (let ((block (tn-local tn))
    (num (tn-local-number tn)))
    (add-global-conflict
     (if (zerop (sbit (ir2-block-written block) num))
     :read-only
     (if (zerop (sbit (ir2-block-live-out block) num))
         :write
         :read))
     tn block num))
  (undefined-value))


;;; Find-Local-References  --  Internal
;;;
;;;    Scan all references to packed TNs in block.  We assign LTN numbers to
;;; each referenced TN, and also build the Kill and Live sets that summarize
;;; the references to each TN for purposes of lifetime analysis.
;;;
;;;    It is possible that we will run out of LTN numbers.  If this happens,
;;; then we return the VOP that we were processing at the time we ran out,
;;; otherwise we return NIL.
;;;
;;;    If a TN is referenced in more than one block, then we must represent
;;; references using Global-Conflicts structures.  When we first see a TN, we
;;; assume it will be local.  If we see a reference later on in a different
;;; block, then we go back and fix the TN to global.
;;;
;;;    We must globalize TNs that have a block other than the current one in
;;; their Local slot and have no Global-Conflicts.  The latter condition is
;;; necessary because we always set Local and Local-Number when we process a
;;; reference to a TN, even when the TN is already known to be global.
;;;
;;;    When we see reference to global TNs during the scan, we add the
;;; global-conflict as :Read-Only, since we don't know the corrent kind until
;;; we are done scanning the block.
;;;
(defun find-local-references (block)
  (declare (type ir2-block block))
  (let ((kill (ir2-block-written block))
    (live (ir2-block-live-out block))
    (tns (ir2-block-local-tns block)))
    (let ((ltn-num (ir2-block-local-tn-count block)))
      (do ((vop (ir2-block-last-vop block)
        (vop-prev vop)))
      ((null vop))
    (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
        ((null ref))
      (let* ((tn (tn-ref-tn ref))
         (local (tn-local tn))
         (kind (tn-kind tn)))
        (unless (member kind '(:component :environment :constant))
          (unless (eq local block)
        (when (= ltn-num local-tn-limit)
          (return-from find-local-references vop))
        (when local
          (unless (tn-global-conflicts tn)
            (convert-to-global tn))
          (add-global-conflict :read-only tn block ltn-num))

        (setf (tn-local tn) block)
        (setf (tn-local-number tn) ltn-num)
        (setf (svref tns ltn-num) tn)
        (incf ltn-num))

          (let ((num (tn-local-number tn)))
        (if (tn-ref-write-p ref)
            (setf (sbit kill num) 1  (sbit live num) 0)
            (setf (sbit live num) 1)))))))

      (setf (ir2-block-local-tn-count block) ltn-num)))
  nil)


;;; Init-Global-Conflict-Kind   --  Internal
;;;
;;;    Finish up the global conflicts for TNs referenced in Block according to
;;; the local Kill and Live sets.
;;;
;;;    We set the kind for TNs already in the global-TNs.  If not written at
;;; all, then is :Read-Only, the default.  Must have been referenced somehow,
;;; or we wouldn't have conflicts for it.
;;;
;;;    We also iterate over all the local TNs, looking for TNs local to this
;;; block that are still live at the block beginning, and thus must be global.
;;; This case is only important when a TN is read in a block but not written in
;;; any other, since otherwise the write would promote the TN to global.  But
;;; this does happen with various passing-location TNs that are magically
;;; written.  This also serves to propagate the lives of erroneously
;;; uninitialized TNs so that consistency checks can detect them.
;;;
(defun init-global-conflict-kind (block)
  (declare (type ir2-block block))
  (let ((live (ir2-block-live-out block)))
    (let ((kill (ir2-block-written block)))
      (do ((conf (ir2-block-global-tns block)
         (global-conflicts-next conf)))
      ((null conf))
    (let ((num (global-conflicts-number conf)))
      (unless (zerop (sbit kill num))
        (setf (global-conflicts-kind conf)
          (if (zerop (sbit live num))
              :write
              :read))))))

    (let ((ltns (ir2-block-local-tns block)))
      (dotimes (i (ir2-block-local-tn-count block))
    (let ((tn (svref ltns i)))
      (unless (or (eq tn :more)
              (tn-global-conflicts tn)
              (zerop (sbit live i)))
        (convert-to-global tn))))))

  (undefined-value))


(defevent split-ir2-block "Split an IR2 block to meet Local-TN-Limit.")

;;; Split-IR2-Blocks  --  Internal
;;;
;;;    Move the code after the VOP Lose in 2block into its own block.  The
;;; block is linked into the emit order following 2block.  Number is the block
;;; number assigned to the new block.  We return the new block.
;;;
(defun split-ir2-blocks (2block lose number)
  (declare (type ir2-block 2block) (type vop lose)
       (type unsigned-byte number))
  (event split-ir2-block (vop-node lose))
  (let ((new (make-ir2-block (ir2-block-block 2block)))
    (new-start (vop-next lose)))
    (setf (ir2-block-number new) number)
    (add-to-emit-order new 2block)

    (do ((vop new-start (vop-next vop)))
    ((null vop))
      (setf (vop-block vop) new))

    (setf (ir2-block-start-vop new) new-start)
    (shiftf (ir2-block-last-vop new) (ir2-block-last-vop 2block) lose)

    (setf (vop-next lose) nil)
    (setf (vop-prev new-start) nil)

    new))


;;; Clear-Lifetime-Info  --  Internal
;;;
;;;    Clear the global and local conflict info in Block so that we can
;;; recompute it without any old cruft being retained.  It is assumed that all
;;; LTN numbers are in use.
;;;
;;;    First we delete all the global conflicts.  The conflict we are deleting
;;; must be the last in the TN's global-conflicts, but we must scan for it in
;;; order to find the previous conflict.
;;;
;;;    Next, we scan the local TNs, nulling out the Local slot in all TNs with
;;; no global conflicts.  This allows these TNs to be treated as local when we
;;; scan the block again.
;;;
;;;    If there are conflicts, then we set Local to one of the conflicting
;;; blocks.  This ensures that Local doesn't hold over Block as its value,
;;; causing the subsequent reanalysis to think that the TN has already been
;;; seen in that block.
;;;
;;;    This function must not be called on blocks that have :More TNs.
;;;
(defun clear-lifetime-info (block)
  (declare (type ir2-block block))
  (setf (ir2-block-local-tn-count block) 0)

  (do ((conf (ir2-block-global-tns block)
         (global-conflicts-next conf)))
      ((null conf)
       (setf (ir2-block-global-tns block) nil))
    (let ((tn (global-conflicts-tn conf)))
      (assert (eq (tn-current-conflict tn) conf))
      (assert (null (global-conflicts-tn-next conf)))
      (do ((current (tn-global-conflicts tn)
            (global-conflicts-tn-next current))
       (prev nil current))
      ((eq current conf)
       (if prev
           (setf (global-conflicts-tn-next prev) nil)
           (setf (tn-global-conflicts tn) nil))
       (setf (tn-current-conflict tn) prev)))))

  (fill (ir2-block-written block) 0)
  (let ((ltns (ir2-block-local-tns block)))
    (dotimes (i local-tn-limit)
      (let ((tn (svref ltns i)))
    (assert (not (eq tn :more)))
    (let ((conf (tn-global-conflicts tn)))
      (setf (tn-local tn)
        (if conf
            (global-conflicts-block conf)
            nil))))))

  (undefined-value))


;;; Coalesce-More-LTN-Numbers  --  Internal
;;;
;;;    This provides a panic mode for assigning LTN numbers when there is a VOP
;;; with so many more operands that they can't all be assigned distinct
;;; numbers.  When this happens, we recover by assigning all the more operands
;;; the same LTN number.  We can get away with this, since all more args (and
;;; results) are referenced simultaneously as far as conflict analysis is
;;; concerned.
;;;
;;;     Block is the IR2-Block that the more VOP is at the end of.  Ops is the
;;; full argument or result TN-Ref list.  Fixed is the types of the fixed
;;; operands (used only to skip those operands.)
;;;
;;;     What we do is grab a LTN number, then make a :Read-Only global conflict
;;; for each more operand TN.  We require that there be no existing global
;;; conflict in Block for any of the operands.  Since conflicts must be cleared
;;; before the first call, this only prohibits the same TN being used both as a
;;; more operand and as any other operand to the same VOP.
;;;
;;;     We don't have to worry about getting the correct conflict kind, since
;;; Init-Global-Conflict-Kind will fix things up.  Similarly,
;;; FIND-LOCAL-REFERENCES will set the local conflict bit corresponding to this
;;; call.
;;;
;;;     We also set the Local and Local-Number slots in each TN.  It is
;;; possible that there are no operands in any given call to this function, but
;;; there had better be either some more args or more results.
;;;
(defun coalesce-more-ltn-numbers (block ops fixed)
  (declare (type ir2-block block) (type (or tn-ref null) ops) (list fixed))
  (let ((num (ir2-block-local-tn-count block)))
    (assert (< num local-tn-limit))
    (incf (ir2-block-local-tn-count block))
    (setf (svref (ir2-block-local-tns block) num) :more)

    (do ((op (do ((op ops (tn-ref-across op))
          (i 0 (1+ i)))
         ((= i (length fixed)) op)
           (declare (type index i)))
         (tn-ref-across op)))
    ((null op))
      (let ((tn (tn-ref-tn op)))
    (assert
      (flet ((frob (refs)
           (do ((ref refs (tn-ref-next ref)))
               ((null ref) t)
             (when (and (eq (vop-block (tn-ref-vop ref)) block)
                (not (eq ref op)))
               (return nil)))))
        (and (frob (tn-reads tn)) (frob (tn-writes tn))))
      () "More operand ~S used more than once in its VOP." op)
    (assert (not (find-in #'global-conflicts-next tn
                  (ir2-block-global-tns block)
                  :key #'global-conflicts-tn)))

    (add-global-conflict :read-only tn block num)
    (setf (tn-local tn) block)
    (setf (tn-local-number tn) num))))
  (undefined-value))


(defevent coalesce-more-ltn-numbers
  "Coalesced LTN numbers for a more operand to meet Local-TN-Limit.")

;;; Lifetime-Pre-Pass  --  Internal
;;;
;;;    Loop over the blocks in Component, assigning LTN numbers and recording
;;; TN birth and death.  The only interesting action is when we run out of
;;; local TN numbers while finding local references.
;;;
;;;    If we run out of LTN numbers while processing a VOP within the block,
;;; then we just split off the VOPs we have successfully processed into their
;;; own block.
;;;
;;;    If we run out of LTN numbers while processing the our first VOP (the
;;; last in the block), then it must be the case that this VOP has large more
;;; operands.  We split the VOP into its own block, and then call
;;; Coalesce-More-Ltn-Numbers to assign all the more args/results the same LTN
;;; number(s).
;;;
;;;    In either case, we clear the lifetime information that we computed so
;;; far, recomputing it after taking corrective action.
;;;
;;;    Whenever we split a block, we finish the pre-pass on the split-off block
;;; by doing Find-Local-References and Init-Global-Conflict-Kind.  This can't
;;; run out of LTN numbers.
;;;
(defun lifetime-pre-pass (component)
  (declare (type component component))
  (let ((counter -1))
    (declare (type fixnum counter))
    (do-blocks-backwards (block component)
      (let ((2block (block-info block)))
    (do ((lose (find-local-references 2block)
           (find-local-references 2block))
         (last-lose nil lose)
         (coalesced nil))
        ((not lose)
         (init-global-conflict-kind 2block)
         (setf (ir2-block-number 2block) (incf counter)))

      (clear-lifetime-info 2block)

      (cond
       ((vop-next lose)
        (assert (not (eq last-lose lose)))
        (let ((new (split-ir2-blocks 2block lose (incf counter))))
          (assert (not (find-local-references new)))
          (init-global-conflict-kind new)))
       (t
        (assert (not (eq lose coalesced)))
        (setq coalesced lose)
        (event coalesce-more-ltn-numbers (vop-node lose))
        (let ((info (vop-info lose))
          (new (if (vop-prev lose)
               (split-ir2-blocks 2block (vop-prev lose)
                         (incf counter))
               2block)))
          (coalesce-more-ltn-numbers new (vop-args lose)
                     (vop-info-arg-types info))
          (coalesce-more-ltn-numbers new (vop-results lose)
                     (vop-info-result-types info))
          (let ((lose (find-local-references new)))
        (assert (not lose)))
          (init-global-conflict-kind new))))))))

  (undefined-value))


;;;; Environment TN stuff:


;;; SETUP-ENVIRONMENT-TN-CONFLICT  --  Internal
;;;
;;;    Add a :LIVE global conflict for TN in 2block if there is none present.
;;; If Debug-P is false (a :ENVIRONMENT TN), then modify any existing conflict
;;; to be :LIVE.
;;;
(defun setup-environment-tn-conflict (tn 2block debug-p)
  (declare (type tn tn) (type ir2-block 2block))
  (let ((block-num (ir2-block-number 2block)))
    (do ((conf (tn-current-conflict tn) (global-conflicts-tn-next conf))
     (prev nil conf))
    ((or (null conf)
         (> (ir2-block-number (global-conflicts-block conf)) block-num))
     (setf (tn-current-conflict tn) prev)
     (add-global-conflict :live tn 2block nil))
      (when (eq (global-conflicts-block conf) 2block)
    (unless (or debug-p
            (eq (global-conflicts-kind conf) :live))
      (setf (global-conflicts-kind conf) :live)
      (setf (svref (ir2-block-local-tns 2block)
               (global-conflicts-number conf))
        nil)
      (setf (global-conflicts-number conf) nil))
    (setf (tn-current-conflict tn) conf)
    (return))))
  (undefined-value))


;;; SETUP-ENVIRONMENT-TN-CONFLICTS  --  Internal
;;;
;;;    Iterate over all the blocks in Env, setting up :LIVE conflicts for TN.
;;; We make the TN global if it isn't already.  The TN must have at least one
;;; reference.
;;;
(defun setup-environment-tn-conflicts (component tn env debug-p)
  (declare (type component component) (type tn tn) (type environment env))
  (when (and debug-p
         (not (tn-global-conflicts tn))
         (tn-local tn))
    (convert-to-global tn))
  (setf (tn-current-conflict tn) (tn-global-conflicts tn))
  (do-blocks-backwards (block component)
    (when (eq (block-environment block) env)
      (let* ((2block (block-info block))
         (last (do ((b (ir2-block-next 2block) (ir2-block-next b))
            (prev 2block b))
               ((not (eq (ir2-block-block b) block))
            prev))))
    (do ((b last (ir2-block-prev b)))
        ((not (eq (ir2-block-block b) block)))
      (setup-environment-tn-conflict tn b debug-p)))))
  (undefined-value))


;;; SETUP-ENVIRONMENT-LIVE-CONFLICTS  --  Internal
;;;
;;;    Iterate over all the environment TNs, adding always-live conflicts as
;;; appropriate.
;;;
(defun setup-environment-live-conflicts (component)
  (declare (type component component))
  (dolist (fun (component-lambdas component))
    (let* ((env (lambda-environment fun))
       (2env (environment-info env)))
      (dolist (tn (ir2-environment-live-tns 2env))
    (setup-environment-tn-conflicts component tn env nil))
      (dolist (tn (ir2-environment-debug-live-tns 2env))
    (setup-environment-tn-conflicts component tn env t))))
  (undefined-value))


;;; Convert-To-Environment-TN  --  Internal
;;;
;;;    Convert a :NORMAL or :DEBUG-ENVIRONMENT TN to an :ENVIRONMENT TN.  This
;;; requires adding :LIVE conflicts to all blocks in TN-ENV.
;;;
(defun convert-to-environment-tn (tn tn-env)
  (declare (type tn tn) (type environment tn-env))
  (assert (member (tn-kind tn) '(:normal :debug-environment)))
  (when (eq (tn-kind tn) :debug-environment)
    (assert (eq (tn-environment tn) tn-env))
    (let ((2env (environment-info tn-env)))
      (setf (ir2-environment-debug-live-tns 2env)
        (delete tn (ir2-environment-debug-live-tns 2env)))))
  (setup-environment-tn-conflicts *compile-component* tn tn-env nil)
  (setf (tn-local tn) nil)
  (setf (tn-local-number tn) nil)
  (setf (tn-kind tn) :environment)
  (setf (tn-environment tn) tn-env)
  (push tn (ir2-environment-live-tns (environment-info tn-env)))
  (undefined-value))


;;;; Flow analysis:

;;; Propagate-Live-TNs  --  Internal
;;;
;;;    For each Global-TN in Block2 that is :Live, :Read or :Read-Only, ensure
;;; that there is a corresponding Global-Conflict in Block1.  If there is none,
;;; make a :Live Global-Conflict.  If there is a :Read-Only conflict, promote
;;; it to :Live.
;;;
;;;    If we did added a new conflict, return true, otherwise false.  We don't
;;; need to return true when we promote a :Read-Only conflict, since it doesn't
;;; reveal any new information to predecessors of Block1.
;;;
;;;    We use the Tn-Current-Conflict to walk through the global
;;; conflicts.  Since the global conflicts for a TN are ordered by block, we
;;; can be sure that the Current-Conflict always points at or before the block
;;; that we are looking at.  This allows us to quickly determine if there is a
;;; global conflict for a given TN in Block1.
;;;
;;;    When we scan down the conflicts, we know that there must be at least one
;;; conflict for TN, since we got our hands on TN by picking it out of a
;;; conflict in Block2.
;;;
;;;    We leave the Current-Conflict pointing to the conflict for Block1.  The
;;; Current-Conflict must be initialized to the head of the Global-Conflicts
;;; for the TN between each flow analysis iteration.
;;;
(defun propagate-live-tns (block1 block2)
  (declare (type ir2-block block1 block2))
  (let ((live-in (ir2-block-live-in block1))
    (did-something nil))
    (do ((conf2 (ir2-block-global-tns block2)
        (global-conflicts-next conf2)))
    ((null conf2))
      (ecase (global-conflicts-kind conf2)
    ((:live :read :read-only)
     (let* ((tn (global-conflicts-tn conf2))
        (tn-conflicts (tn-current-conflict tn))
        (number1 (ir2-block-number block1)))
       (assert tn-conflicts)
       (do ((current tn-conflicts (global-conflicts-tn-next current))
        (prev nil current))
           ((or (null current)
            (> (ir2-block-number (global-conflicts-block current))
               number1))
        (setf (tn-current-conflict tn) prev)
        (add-global-conflict :live tn block1 nil)
        (setq did-something t))
         (when (eq (global-conflicts-block current) block1)
           (case (global-conflicts-kind current)
         (:live)
         (:read-only
          (setf (global-conflicts-kind current) :live)
          (setf (svref (ir2-block-local-tns block1)
                   (global-conflicts-number current))
            nil)
          (setf (global-conflicts-number current) nil)
          (setf (tn-current-conflict tn) current))
         (t
          (setf (sbit live-in (global-conflicts-number current)) 1)))
           (return)))))
    (:write)))
    did-something))


;;; Lifetime-Flow-Analysis  --  Internal
;;;
;;;    Do backward global flow analysis to find all TNs live at each block
;;; boundary.
;;;
(defun lifetime-flow-analysis (component)
  (loop
    (reset-current-conflict component)
    (let ((did-something nil))
      (do-blocks-backwards (block component)
    (let* ((2block (block-info block))
           (last (do ((b (ir2-block-next 2block) (ir2-block-next b))
              (prev 2block b))
             ((not (eq (ir2-block-block b) block))
              prev))))

      (dolist (b (block-succ block))
        (when (and (block-start b)
               (propagate-live-tns last (block-info b)))
          (setq did-something t)))

      (do ((b (ir2-block-prev last) (ir2-block-prev b))
           (prev last b))
          ((not (eq (ir2-block-block b) block)))
        (when (propagate-live-tns b prev)
          (setq did-something t)))))

      (unless did-something (return))))

  (undefined-value))


;;;; Post-pass:

;;; Note-Conflicts  --  Internal
;;;
;;;    Note that TN conflicts with all current live TNs.  Num is TN's LTN
;;; number.  We bit-ior Live-Bits with TN's Local-Conflicts, and set TN's
;;; number in the conflicts of all TNs in Live-List.
;;;
(defun note-conflicts (live-bits live-list tn num)
  (declare (type tn tn) (type (or tn null) live-list)
       (type local-tn-bit-vector live-bits)
       (type local-tn-number num))
  (let ((lconf (tn-local-conflicts tn)))
    (bit-ior live-bits lconf lconf))
  (do ((live live-list (tn-next* live)))
      ((null live))
    (setf (sbit (tn-local-conflicts live) num) 1))
  (undefined-value))


;;; Compute-Save-Set  --  Internal
;;;
;;;    Compute a bit vector of the TNs live after VOP that aren't results.
;;;
(defun compute-save-set (vop live-bits)
  (declare (type vop vop) (type local-tn-bit-vector live-bits))
  (let ((live (bit-vector-copy live-bits)))
    (do ((r (vop-results vop) (tn-ref-across r)))
    ((null r))
      (let ((tn (tn-ref-tn r)))
    (ecase (tn-kind tn)
      ((:normal :debug-environment)
       (setf (sbit live (tn-local-number tn)) 0))
      (:environment :component))))
    live))


;;; SAVED-AFTER-READ  --  Internal
;;;
;;;    Used to determine whether a :DEBUG-ENVIRONMENT TN should be considered
;;; live at block end.  We return true if a VOP with non-null SAVE-P appears
;;; before the first read of TN (hence is seen first in our backward scan.)
;;;
(defun saved-after-read (tn block)
  (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
      ((null vop) t)
    (when (vop-info-save-p (vop-info vop)) (return t))
    (when (find-in #'tn-ref-across tn (vop-args vop) :key #'tn-ref-tn)
      (return nil))))

;;; MAKE-DEBUG-ENVIRONMENT-TNS-LIVE  --  Internal
;;;
;;; If the block has no successors, or its successor is the component tail,
;;; then all :DEBUG-ENVIRONMENT TNs are always added, regardless of whether
;;; they appeared to be live.  This ensures that these TNs are considered to be
;;; live throughout blocks that read them, but don't have any interesting
;;; successors (such as a return or tail call.)  In this case, we set the
;;; corresponding bit in LIVE-IN as well.
;;;
(defun make-debug-environment-tns-live (block live-bits live-list)
  (let* ((1block (ir2-block-block block))
     (live-in (ir2-block-live-in block))
     (succ (block-succ 1block))
     (next (ir2-block-next block)))
    (when (and next
           (not (eq (ir2-block-block next) 1block))
           (or (null succ)
           (eq (first succ)
               (component-tail (block-component 1block)))))
      (do ((conf (ir2-block-global-tns block)
         (global-conflicts-next conf)))
      ((null conf))
    (let* ((tn (global-conflicts-tn conf))
           (num (global-conflicts-number conf)))
      (when (and num (zerop (sbit live-bits num))
             (eq (tn-kind tn) :debug-environment)
             (eq (tn-environment tn) (block-environment 1block))
             (saved-after-read tn block))
        (note-conflicts live-bits live-list tn num)
        (setf (sbit live-bits num) 1)
        (push-in tn-next* tn live-list)
        (setf (sbit live-in num) 1))))))

  (values live-bits live-list))


;;; Compute-Initial-Conflicts  --  Internal
;;;
;;;    Return as values, a LTN bit-vector and a list (threaded by TN-Next*)
;;; representing the TNs live at the end of Block (exclusive of :Live TNs).
;;;
;;; We iterate over the TNs in the global conflicts that are live at the block
;;; end, setting up the TN-Local-Conflicts and TN-Local-Number, and adding the
;;; TN to the live list.
;;;
;;; If a :MORE result is not live, we effectively fake a read to it.  This is
;;; part of the action described in ENSURE-RESULTS-LIVE.
;;;
;;; At the end, we call MAKE-DEBUG-ENVIRONEMNT-TNS-LIVE to make debug
;;; environment TNs appear live when appropriate, even when they aren't.
;;;
;;; ### Note: we alias the global-conflicts-conflicts here as the
;;; tn-local-conflicts.
;;;
(defun compute-initial-conflicts (block)
  (declare (type ir2-block block))
  (let* ((live-in (ir2-block-live-in block))
     (ltns (ir2-block-local-tns block))
     (live-bits (bit-vector-copy live-in))
     (live-list nil))

    (do ((conf (ir2-block-global-tns block)
           (global-conflicts-next conf)))
    ((null conf))
      (let ((bits (global-conflicts-conflicts conf))
        (tn (global-conflicts-tn conf))
        (num (global-conflicts-number conf))
        (kind (global-conflicts-kind conf)))
    (setf (tn-local-number tn) num)
    (unless (eq kind :live)
      (cond ((not (zerop (sbit live-bits num)))
         (bit-vector-replace bits live-bits)
         (setf (sbit bits num) 0)
         (push-in tn-next* tn live-list))
        ((and (eq (svref ltns num) :more)
              (eq kind :write))
         (note-conflicts live-bits live-list tn num)
         (setf (sbit live-bits num) 1)
         (push-in tn-next* tn live-list)
         (setf (sbit live-in num) 1)))

      (setf (tn-local-conflicts tn) bits))))

    (make-debug-environment-tns-live block live-bits live-list)))


;;; DO-SAVE-P-STUFF  --  Internal
;;;
;;;    A function called in Conflict-Analyze-1-Block when we have a VOP with
;;; SAVE-P true.  We compute the save-set, and if :FORCE-TO-STACK, force all
;;; the live TNs to be stack environment TNs.
;;;
(defun do-save-p-stuff (vop block live-bits)
  (declare (type vop vop) (type ir2-block block)
       (type local-tn-bit-vector live-bits))
  (let ((ss (compute-save-set vop live-bits)))
    (setf (vop-save-set vop) ss)
    (when (eq (vop-info-save-p (vop-info vop)) :force-to-stack)
      (do-live-tns (tn ss block)
    (unless (eq (tn-kind tn) :component)
      (force-tn-to-stack tn)
      (unless (eq (tn-kind tn) :environment)
        (convert-to-environment-tn
         tn
         (block-environment (ir2-block-block block))))))))
  (undefined-value))


(eval-when (compile eval)

;;; Frob-More-TNs  --  Internal
;;;
;;;    Used in SCAN-VOP-REFS to simultaneously do something to all of the TNs
;;; referenced by a big more arg.  We have to treat these TNs specially, since
;;; when we set or clear the bit in the live TNs, the represents a change in
;;; the liveness of all the more TNs.  If we iterated as normal, the next more
;;; ref would be thought to be not live when it was, etc.  We update Ref to be
;;; the last :more ref we scanned, so that the main loop will step to the next
;;; non-more ref.
;;;
(defmacro frob-more-tns (action)
  `(when (eq (svref ltns num) :more)
     (let ((prev ref))
       (do ((mref (tn-ref-next-ref ref) (tn-ref-next-ref mref)))
       ((null mref))
     (let ((mtn (tn-ref-tn mref)))
       (unless (eql (tn-local-number mtn) num)
         (return))
       ,action)
     (setq prev mref))
       (setq ref prev))))


;;; SCAN-VOP-REFS  --  Internal
;;;
;;;        Handle the part of CONFLICT-ANALYZE-1-BLOCK that scans the REFs for the
;;; current VOP.  This macro shamelessly references free variables in C-A-1-B.
;;;
(defmacro scan-vop-refs ()
  '(do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
       ((null ref))
     (let* ((tn (tn-ref-tn ref))
        (num (tn-local-number tn)))
       (cond
    ((not num))
    ((not (zerop (sbit live-bits num)))
     (when (tn-ref-write-p ref)
       (setf (sbit live-bits num) 0)
       (deletef-in tn-next* live-list tn)
       (frob-more-tns (deletef-in tn-next* live-list mtn))))
    (t
     (assert (not (tn-ref-write-p ref)))
     (note-conflicts live-bits live-list tn num)
     (frob-more-tns (note-conflicts live-bits live-list mtn num))
     (setf (sbit live-bits num) 1)
     (push-in tn-next* tn live-list)
     (frob-more-tns (push-in tn-next* mtn live-list)))))))


;;; ENSURE-RESULTS-LIVE  --  Internal
;;;
;;;    This macro is called by CONFLICT-ANALYZE-1-BLOCK to scan the current
;;; VOP's results, and make any dead ones live.  This is necessary, since even
;;; though a result is dead after the VOP, it may be in use for an extended
;;; period within the VOP (especially if it has :FROM specified.)  During this
;;; interval, temporaries must be noted to conflict with the result.  More
;;; results are finessed in COMPUTE-INITIAL-CONFLICTS, so we ignore them here.
;;;
(defmacro ensure-results-live ()
  '(do ((res (vop-results vop) (tn-ref-across res)))
       ((null res))
     (let* ((tn (tn-ref-tn res))
        (num (tn-local-number tn)))
       (when (and num (zerop (sbit live-bits num)))
     (unless (eq (svref ltns num) :more)
       (note-conflicts live-bits live-list tn num)
       (setf (sbit live-bits num) 1)
       (push-in tn-next* tn live-list))))))

); Eval-When (Compile Eval)


;;; Conflict-Analyze-1-Block  --  Internal
;;;
;;;    Compute the block-local conflict information for Block.  We iterate over
;;; all the TN-Refs in a block in reference order, maintaining the set of live
;;; TNs in both a list and a bit-vector representation.
;;;
(defun conflict-analyze-1-block (block)
  (declare (type ir2-block block))
  (multiple-value-bind
      (live-bits live-list)
      (compute-initial-conflicts block)
    (let ((ltns (ir2-block-local-tns block)))
      (do ((vop (ir2-block-last-vop block)
        (vop-prev vop)))
      ((null vop))
    (when (vop-info-save-p (vop-info vop))
      (do-save-p-stuff vop block live-bits))
    (ensure-results-live)
    (scan-vop-refs)))))


;;; Lifetime-Post-Pass  --  Internal
;;;
;;;    Conflict analyze each block, and also add it
(defun lifetime-post-pass (component)
  (declare (type component component))
  (do-ir2-blocks (block component)
    (conflict-analyze-1-block block)))


;;;; Alias TN stuff:

;;; MERGE-ALIAS-BLOCK-CONFLICTS  --  Internal
;;;
;;;    Destructively modify Oconf to include the conflict information in Conf.
;;;
(defun merge-alias-block-conflicts (conf oconf)
  (declare (type global-conflicts conf oconf))
  (let* ((kind (global-conflicts-kind conf))
     (num (global-conflicts-number conf))
     (okind (global-conflicts-kind oconf))
     (onum (global-conflicts-number oconf))
     (block (global-conflicts-block oconf))
     (ltns (ir2-block-local-tns block)))
    (cond
     ((eq okind :live))
     ((eq kind :live)
      (setf (global-conflicts-kind oconf) :live)
      (setf (svref ltns onum) nil)
      (setf (global-conflicts-number oconf) nil))
     (t
      (unless (eq kind okind)
    (setf (global-conflicts-kind oconf) :read))
      ;;
      ;; Make original conflict with all the local TNs the alias conflicted
      ;; with.
      (bit-ior (global-conflicts-conflicts oconf)
           (global-conflicts-conflicts conf)
           t)
      (flet ((frob (x)
           (unless (zerop (sbit x num))
         (setf (sbit x onum) 1))))
    ;;
    ;; Make all the local TNs that conflicted with the alias conflict
    ;; with the original.
    (dotimes (i (ir2-block-local-tn-count block))
      (let ((tn (svref ltns i)))
        (when (and tn (not (eq tn :more))
               (null (tn-global-conflicts tn)))
          (frob (tn-local-conflicts tn)))))
    ;;
    ;; Same for global TNs...
    (do ((current (ir2-block-global-tns block)
              (global-conflicts-next current)))
        ((null current))
      (unless (eq (global-conflicts-kind current) :live)
        (frob (global-conflicts-conflicts current))))
    ;;
    ;; Make the original TN live everywhere that the alias was live.
    (frob (ir2-block-written block))
    (frob (ir2-block-live-in block))
    (frob (ir2-block-live-out block))
    (do ((vop (ir2-block-start-vop block)
          (vop-next vop)))
        ((null vop))
      (let ((sset (vop-save-set vop)))
        (when sset (frob sset)))))))
    ;;
    ;; Delete the alias's conflict info.
    (when num
      (setf (svref ltns num) nil))
    (deletef-in global-conflicts-next (ir2-block-global-tns block) conf))

  (undefined-value))


;;; CHANGE-GLOBAL-CONFLICTS-TN  --  Internal
;;;
;;;    Co-opt Conf to be a conflict for TN.
;;;
(defun change-global-conflicts-tn (conf new)
  (declare (type global-conflicts conf) (type tn new))
  (setf (global-conflicts-tn conf) new)
  (let ((ltn-num (global-conflicts-number conf))
    (block (global-conflicts-block conf)))
    (deletef-in global-conflicts-next (ir2-block-global-tns block) conf)
    (setf (global-conflicts-next conf) nil)
    (insert-block-global-conflict conf block)
    (when ltn-num
      (setf (svref (ir2-block-local-tns block) ltn-num) new)))
  (undefined-value))


;;; ENSURE-GLOBAL-TN  --  Internal
;;;
;;;    Do CONVERT-TO-GLOBAL on TN if it has no global conflicts.  Copy the
;;; local conflicts into the global bit vector.
;;;
(defun ensure-global-tn (tn)
  (declare (type tn tn))
  (cond ((tn-global-conflicts tn))
    ((tn-local tn)
     (convert-to-global tn)
     (bit-ior (global-conflicts-conflicts (tn-global-conflicts tn))
          (tn-local-conflicts tn)
          t))
    (t
     (assert (and (null (tn-reads tn)) (null (tn-writes tn))))))
  (undefined-value))


;;; MERGE-ALIAS-CONFLICTS  --  Internal
;;;
;;;    For each :ALIAS TN, destructively merge the conflict info into the
;;; original TN and replace the uses of the alias.
;;;
;;; For any block that uses only the alias TN, just insert that conflict into
;;; the conflicts for the original TN, changing the LTN map to refer to the
;;; original TN.  This gives a result indistinguishable from the what there
;;; would have been if the original TN had always been referenced.  This leaves
;;; no sign that an alias TN was ever involved.
;;;
;;; If a block has references to both the alias and the original TN, then we
;;; call MERGE-ALIAS-BLOCK-CONFLICTS to combine the conflicts into the original
;;; conflict.
;;;
(defun merge-alias-conflicts (component)
  (declare (type component component))
  (do ((tn (ir2-component-alias-tns (component-info component))
       (tn-next tn)))
      ((null tn))
    (let ((original (tn-save-tn tn)))
      (ensure-global-tn tn)
      (ensure-global-tn original)
      (let ((conf (tn-global-conflicts tn))
        (oconf (tn-global-conflicts original))
        (oprev nil))
    (loop
      (unless oconf
        (if oprev
        (setf (global-conflicts-tn-next oprev) conf)
        (setf (tn-global-conflicts original) conf))
        (do ((current conf (global-conflicts-tn-next current)))
        ((null current))
          (change-global-conflicts-tn current original))
        (return))
      (let* ((block (global-conflicts-block conf))
         (num (ir2-block-number block))
         (onum (ir2-block-number (global-conflicts-block oconf))))

        (cond ((< onum num)
           (shiftf oprev oconf (global-conflicts-tn-next oconf)))
          ((> onum num)
           (if oprev
               (setf (global-conflicts-tn-next oprev) conf)
               (setf (tn-global-conflicts original) conf))
           (change-global-conflicts-tn conf original)
           (shiftf oprev conf (global-conflicts-tn-next conf) oconf))
          (t
           (merge-alias-block-conflicts conf oconf)
           (shiftf oprev oconf (global-conflicts-tn-next oconf))
           (setf conf (global-conflicts-tn-next conf)))))
      (unless conf (return))))

      (flet ((frob (refs)
           (let ((ref refs)
             (next nil))
         (loop
           (unless ref (return))
           (setq next (tn-ref-next ref))
           (change-tn-ref-tn ref original)
           (setq ref next)))))
    (frob (tn-reads tn))
    (frob (tn-writes tn)))
      (setf (tn-global-conflicts tn) nil)))

  (undefined-value))


;;; Lifetime-Analyze  --  Interface
;;;
;;;
(defun lifetime-analyze (component)
  (lifetime-pre-pass component)
  (setup-environment-live-conflicts component)
  (lifetime-flow-analysis component)
  (lifetime-post-pass component)
  (merge-alias-conflicts component))


;;;; Conflict testing:

;;; TNs-Conflict-Local-Global  --  Internal
;;;
;;;    Test for a conflict between the local TN X and the global TN Y.  We just
;;; look for a global conflict of Y in X's block, and then test for conflict in
;;; that block.
;;; [### Might be more efficient to scan Y's global conflicts.  This depends on
;;; whether there are more global TNs than blocks.]
;;;
(defun tns-conflict-local-global (x y)
  (let ((block (tn-local x)))
    (do ((conf (ir2-block-global-tns block)
           (global-conflicts-next conf)))
    ((null conf) nil)
      (when (eq (global-conflicts-tn conf) y)
    (let ((num (global-conflicts-number conf)))
      (return (or (not num)
              (not (zerop (sbit (tn-local-conflicts x)
                    num))))))))))


;;; TNs-Conflict-Global-Global  --  Internal
;;;
;;;    Test for conflict between two global TNs X and Y.
;;;
(defun tns-conflict-global-global (x y)
  (declare (type tn x y))
  (let* ((x-conf (tn-global-conflicts x))
     (x-num (ir2-block-number (global-conflicts-block x-conf)))
     (y-conf (tn-global-conflicts y))
     (y-num (ir2-block-number (global-conflicts-block y-conf))))

    (macrolet ((advance (n c)
         `(progn
            (setq ,c (global-conflicts-tn-next ,c))
            (unless ,c (return-from tns-conflict-global-global nil))
            (setq ,n (ir2-block-number (global-conflicts-block ,c)))))
           (scan (g l lc)
         `(do ()
              ((>= ,g ,l))
            (advance ,l ,lc))))

      (loop
    ;; x-conf, y-conf true, x-num, y-num corresponding block numbers.
    (scan x-num y-num y-conf)
    (scan y-num x-num x-conf)
    (when (= x-num y-num)
      (let ((ltn-num-x (global-conflicts-number x-conf)))
        (unless (and ltn-num-x
             (global-conflicts-number y-conf)
             (zerop (sbit (global-conflicts-conflicts y-conf)
                      ltn-num-x)))
          (return t))
        (advance x-num x-conf)
        (advance y-num y-conf)))))))


;;; TNs-Conflict  --  Interface
;;;
;;;    Return true if X and Y are distinct and the lifetimes of X and Y overlap
;;; at any point.
;;;
(defun tns-conflict (x y)
  (declare (type tn x y))
  (let ((x-kind (tn-kind x))
    (y-kind (tn-kind y)))
    (cond ((eq x y) nil)
      ((or (eq x-kind :component) (eq y-kind :component)) t)
      ((tn-global-conflicts x)
       (if (tn-global-conflicts y)
           (tns-conflict-global-global x y)
           (tns-conflict-local-global y x)))
      ((tn-global-conflicts y)
       (tns-conflict-local-global x y))
      (t
       (and (eq (tn-local x) (tn-local y))
        (not (zerop (sbit (tn-local-conflicts x)
                  (tn-local-number y)))))))))